home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: New Zealand Amiga Users Group
/
New Zealand Amiga Users Group Newsdisk v03 (1987-02)(NZAmigaUG).zip
/
New Zealand Amiga Users Group Newsdisk v03 (1987-02)(NZAmigaUG).adf
/
BASIC
/
ObEdlo
(
.txt
)
< prev
next >
Wrap
AmigaBASIC Source Code
|
1993-12-02
|
12KB
|
579 lines
' Last modified : Jan 23, 1987
DEFINT a-z
' Format of the file produced by this program
'
' long ColorSetOffset
' long DataSetOffset
' long depth number of bit planes
' long width width of object in pixels
' long height height of object in pixels
' short flags:
' fVsprite=1 TRUE if its a vsprite, FALSE if its a BOB
collisionPlaneIncluded=2 'never set by this editor
imageShadowIncluded=4 'never set by this editor
SAVEBACK=8 'save background before drawing BOB
OVERLAY=16 'color 0 for BOB is transparent, not black
SAVEBOB=32 'let BOB act like a paint brush
' short planePick which playfield planes do object planes map to
' short planeOnOff set to 0 by object editor
' <first bit-plane>
' <second bit-plane> /* must begin on even byte boundary */
' :
' <last bit-plane>
' <imageShadow bit-plane> not currently produced by object editor
' <collision bit-plane> not currently produced by object editor
'
DEF FNArraySize& = 3+INT((Bobright+16)/16)*(bobbottom+1)*Depth
DIM DrawRect(3),ToolName$(6)
scrn=-1 'puts window in workbench screen
Depth=2
WinY=185: WinX=309: cbtop=100
'If BOBs are to be created with other than 2 bit-planes
' alter next 3 lines (only if machine has more than 256k)
INPUT "Screen depth (1-5)";Depth
scrn=1
SCREEN scrn,320,200,Depth,1
WINDOW 2,"GT's Object Editor",,31,scrn
PRINT "GT's Amiga-BASIC Object Editor"
LIBRARY "graphics.library"
GOSUB InitConstant
GOSUB InitFile
GOSUB InitMenu
StartOver:
ON MENU GOSUB CheckMenu : MENU ON
ON MOUSE GOSUB CheckMouse : MOUSE ON
ON BREAK GOSUB IgnoreBreak: BREAK ON
DrawBoundary
GOSUB PrintStatus
Unfinished = -1
WHILE Unfinished
SLEEP 'this program is completely event driven
WEND
MENU RESET
CLS
END
InitConstant:
IF FRE(-1)>50000 THEN MaxTool=6 :ELSE MaxTool=5
ToolMode=1
currentcolor=1
MaxY=120: MaxX=250
MaxY10=MaxY+10: MaxX10=MaxX+10
statusline=22
Top = 20: Left = 230
MaxBobRight=3*0.8*FRE(0)/4 : MaxBobBottom=0.8*FRE(0)/4
RETURN
InitFile:
CLS
IF Depth = 2 THEN
PRINT "Enter 1 if you want to edit sprites"
INPUT "Enter 0 if you want to edit bobs > ",fVsprite
ELSE
fVsprite = 0 'user can't edit sprite
END IF
bobbottom=31
IF fVsprite =0 THEN INPUT "Enter bob size: X,Y ",Bobright,bobbottom
CLS
FileName$=""
Flags=SAVEBACK+OVERLAY+fVsprite
IF fVsprite = 0 THEN Bobright=Bobright-1:bobbottom=bobbottom-1 :ELSE Bobright=15
currentX=Bobright:currentY=bobbottom
maxcolor=2^Depth - 1
DIM rgb%(maxcolor,3)
PlanePick=maxcolor
Change=0
RETURN
InitMenu:
MENU 1,0,1,"File"
MENU 1,1,1,"New"
MENU 1,2,1,"Open ..."
MENU 1,3,1,"Save"
MENU 1,5,1,"Quit"
MENU 1,4,1,"Save as ..."
MENU 2,0,1,"Tools"
MENU 3,0,1,"Enlarge"
MENU 3,1,1,"4x4"
MENU 3,2,1,"1x1"
MENU 4,0,1,""
ToolName$(1)="Pen"
ToolName$(2)="Line"
ToolName$(3)="Oval"
ToolName$(4)="Rectangle"
ToolName$(5)="Eraser"
ToolName$(6)="Paint"
FOR i=1 TO MaxTool
MENU 2,i,1,ToolName$(i)
NEXT i
RETURN
CheckMenu:
MenuId=MENU(0)
MenuItem=MENU(1)
ON MenuId GOTO FileMenu,ToolsMenu,FatBits
CheckMouse:
GetCurrentXY
IF currentY>cbtop AND currentY<cbtop+30 AND currentX>235 THEN EditColor
IF currentY>MaxY+10 THEN CheckColor
IF NOT fEnlarge THEN
IF currentY>bobbottom+10 OR currentX>Bobright+10 THEN RETURN
IF currentY>=bobbottom AND currentX>=Bobright THEN ChangeSizePicture
IF (currentY>bobbottom OR currentX>Bobright) THEN RETURN
ELSE
IF currentX>Bobright*Offset OR currentY>bobbottom*Offset THEN RETURN
END IF
StartY=currentY
StartX=currentX
Change=-1
ON ToolMode GOSUB Pen,DrawLine,DrawCircle,DrawRectangle,ErasePicture,PaintPicture
RETURN
DrawLine:
WHILE MOUSE(0)<>0
GetCurrentXY
IF InsideBob THEN
InvertVideo
LINE (StartX,StartY)-(currentX,currentY) 'draw line
LINE (StartX,StartY)-(currentX,currentY) 'erase line
NormalVideo
END IF
WEND
LINE (StartX,StartY)-(currentX,currentY),currentcolor
RETURN
FatBits:
ON MenuItem GOTO Enlarge, Shrink
Enlarge:
IF fEnlarge THEN RETURN
fBig = -1
IF bobbottom > 31 THEN
LOCATE 17,1:PRINT "Y >= 31 too large to enlarge. ";
ELSEIF Bobright >=100 THEN
LOCATE 17,1:PRINT "X >=50 too large to enlarge. ";
ELSE
fBig = 0
END IF
IF fBig THEN
PRINT "Press any key to continue";
10 a$=INKEY$:IF a$="" GOTO 10
LOCATE 17,1:PRINT " ";
PRINT " ";
RETURN
END IF
Offset = 4:OffsetB=Offset-1
ChangeToolsMode 0 'Disable Tools
MenuItem = 1
GOSUB ToolsMenu
fEnlarge = -1 'Enlarge flag
DIM BobArray(FNArraySize&)
GET (0,0)-(Bobright,bobbottom),BobArray
LINE (Left-1,Top-1)-(Left+Bobright+1,Top+bobbottom+1),,b
PUT (Left,Top),BobArray
ERASE BobArray
LINE (0,0)-(Bobright*2,bobbottom*2),0,bf
LINE (-1,-1)-((Bobright+1)*Offset,(bobbottom+1)*Offset),,b
m=0:n=0
FOR i=Left TO Left+Bobright
n=0
FOR j=Top TO Top+bobbottom
x=POINT(i,j)
IF x>0 THEN LINE (m,n)-(m+OffsetB,n+OffsetB),x,bf
n=n+Offset
NEXT j
m=m+Offset
NEXT i
RETURN
Shrink:
IF fEnlarge = 0 THEN RETURN
ChangeToolsMode 1
fEnlarge = 0
DIM BobArray(FNArraySize&)
GET (Left,Top)-(Left+Bobright,Top+bobbottom),BobArray
LINE (Left-1,Top-1)-(Left+Bobright+1,Top+bobbottom+1),0,bf
LINE (0,0)-(Bobright*Offset+Offset,Offset*bobbottom+Offset),0,bf
DrawBoundary
PUT (0,0),BobArray
ERASE BobArray
RETURN
SUB ChangeToolsMode (Mode) STATIC
SHARED MaxTool
FOR i=2 TO MaxTool
MENU 2,i,Mode
NEXT
END SUB
Pen:
IF fEnlarge THEN GOTO BigPen
GetCurrentXY
IF InsideBob THEN PSET (currentX,currentY),currentcolor
WHILE MOUSE(0)<>0
GetCurrentXY
IF NOT InsideBob THEN RETURN
LINE -(currentX,currentY),currentcolor
WEND
RETURN
BigPen:
GOSUB GetX1Y1
IF InsideBob THEN
PSET (currentX+Left,currentY+Top),currentcolor
LINE (x1,y1)-(x1+OffsetB,y1+OffsetB),currentcolor,bf
END IF
WHILE MOUSE(0)<>0
GOSUB GetX1Y1
IF InsideBob THEN
PSET (currentX+Left,currentY+Top),currentcolor
LINE (x1,y1)-(x1+OffsetB,y1+OffsetB),currentcolor,bf
END IF
WEND
RETURN
GetX1Y1:
GetCurrentXY
IF (currentX>=0 AND currentX < (Bobright+1)*Offset) AND (currentY>=0 AND currentY <(bobbottom+1)*Offset) THEN
InsideBob = -1
currentX = INT(currentX/Offset)
x1=currentX*Offset
currentY=INT(currentY/Offset)
y1=currentY*Offset
ELSE
InsideBob = 0
END IF
RETURN
DrawCircle:
GOSUB TrackRect
CenterX=(DrawRect(1)+DrawRect(3))/2
CenterY=(DrawRect(2)+DrawRect(0))/2
RadiusX=(DrawRect(3)-DrawRect(1))/2
RadiusY=(DrawRect(2)-DrawRect(0))/2
IF RadiusX=0 OR RadiusY=0 THEN RETURN
Aspect!=ABS(RadiusY/RadiusX)
IF RadiusX < RadiusY THEN RadiusX=RadiusY
CIRCLE (CenterX,CenterY),RadiusX,currentcolor,,,Aspect!
RETURN
DrawRectangle:
GOSUB TrackRect
LINE (DrawRect(1),DrawRect(0))-(DrawRect(3),DrawRect(2)),currentcolor,b
RETURN
ErasePicture:
WHILE MOUSE(0)<>0
GetCurrentXY
IF currentX-5<0 OR currentY-3<0 THEN InsideBob=0
IF InsideBob THEN
LINE (currentX-5,currentY-3)-(currentX,currentY),1,bf
LINE (currentX-5,currentY-3)-(currentX,currentY),0,bf
END IF
WEND
DrawBoundary
RETURN
PaintPicture:
IF InsideBob THEN
LINE(0,bobbottom+1)-(Bobright+1,bobbottom+1),currentcolor
LINE(Bobright+1,0)-(Bobright+1,bobbottom+1),currentcolor
PAINT (currentX, currentY),currentcolor
DrawBoundary
END IF
RETURN
TrackRect:
WHILE MOUSE(0)<>0
GetCurrentXY
IF InsideBob THEN
DrawRect(0)=StartY
DrawRect(1)=StartX
DrawRect(2)=currentY
DrawRect(3)=currentX
InvertVideo
FrameRect DrawRect() 'Draw it
FrameRect DrawRect() 'Erase it
NormalVideo
END IF
WEND
IF currentY<StartY THEN DrawRect(0)=currentY: DrawRect(2)=StartY
IF currentX<StartX THEN DrawRect(1)=currentX: DrawRect(3)=StartX
RETURN
ChangeSizePicture:
MaxMem = 0.8 * FRE(0)
COLOR 0
DrawBoundary
COLOR 1
InvertVideo
WHILE MOUSE(0)<>0
GetCurrentXY
IF (currentY < MaxY) AND (currentY > 0) THEN
IF (currentX <= MaxX) AND (currentX >= 10) THEN
IF MaxMem > (Depth * currentX * currentY /8) THEN
IF fVsprite = 1 THEN Bobright = 15:currentX=15::ELSE Bobright=currentX
bobbottom=currentY
DrawBoundary
DrawBoundary
END IF
END IF
END IF
WEND
NormalVideo
GOSUB GetPicture
GOSUB RedrawPicture
RETURN
ToolsMenu:
ToolMode=MenuItem
GOSUB PrintToolStatus
RETURN
FileMenu:
ON MenuItem GOSUB NewFile,OpenFile,SaveFile,SaveFileAs,Quit
RETURN
NewFile:
GOSUB CheckSave
IF CancelCommand THEN RETURN
CLS
GOSUB InitFile
GOTO StartOver
OpenFile:
GOSUB CheckSave
IF CancelCommand THEN RETURN
CLS
INPUT "Enter Filename > ",FileName$
IF FileName$="" THEN NewFile
OPEN FileName$ FOR INPUT AS 1
ColorSet=CVL(INPUT$(4,1))
DataSet=CVL(INPUT$(4,1))
Depth=CVL(INPUT$(4,1))
Bobright=CVL(INPUT$(4,1)) - 1
bobbottom=CVL(INPUT$(4,1)) - 1
REM --- UNDONE if ColorSet<>0 or DataSet<>0, read image.editor format file
Flags=CVI(INPUT$(2,1))
IF Flags AND 1 THEN fVsprite = 1 :ELSE fVsprite = 0
IF PlanePick <> CVI(INPUT$(2,1)) THEN
PRINT "Error: file not compatible with this SCREEN"
ELSE
PlaneOnOff=CVI(INPUT$(2,1))
ArraySize&=FNArraySize&
DIM BobArray(ArraySize&)
BobArray(0)=Bobright + 1
BobArray(1)=bobbottom + 1
BobArray(2)=Depth
FOR i=3 TO ArraySize&-1
BobArray(i)=CVI(INPUT$(2,1))
NEXT i
CLS
currentX=Bobright: currentY=bobbottom
GOSUB RedrawPicture
END IF
CLOSE #1
Change=0
GOTO StartOver
SaveFileAs:
FileName$=""
SaveFile:
IF fEnlarge THEN GOSUB Shrink
GOSUB GetPicture
IF FileName$="" THEN CLS: INPUT "Enter Filename > ",FileName$
IF FileName$<>"" THEN
OPEN FileName$ FOR OUTPUT AS 1
PRINT #1, MKL$(0); 'ColorSet
PRINT #1, MKL$(0); 'DataSet
PRINT #1, MKI$(0);MKI$(BobArray(2)); 'depth
PRINT #1, MKI$(0);MKI$(BobArray(0)); 'width
PRINT #1, MKI$(0);MKI$(BobArray(1)); 'height
PRINT #1, MKI$(Flags);
PRINT #1, MKI$(PlanePick); 'planePick
PRINT #1, MKI$(0); 'planeOnOff
FOR i=3 TO ArraySize&-1
PRINT #1, MKI$(BobArray(i));
NEXT i
IF fVsprite THEN
'Output the colors for sprite> Change output values for different colors
PRINT #1,MKI$(&Hff); 'White. Color 1
PRINT #1,MKI$(0); 'Black. Color 2
PRINT #1,MKI$(&Hf80); 'Orange. Color 3
END IF
CLOSE#1
END IF
GOSUB RedrawPicture
Change=0
RETURN
Quit:
Cancel=0
GOSUB CheckSave
IF CancelCommand THEN RETURN
Unfinished=0
RETURN
GetPicture:
ArraySize&=FNArraySize&
DIM BobArray(ArraySize&)
GET (0,0)-(Bobright,bobbottom),BobArray
RETURN
RedrawPicture:
CLS
PUT (0,0),BobArray,PSET
ERASE BobArray
DrawBoundary
GOSUB PrintStatus
RETURN
PrintStatus:
PrintCurrentXY
GOSUB PrintToolStatus
GOSUB PrintColorBar
GOSUB PrintEditBox
RETURN
PrintToolStatus:
LOCATE statusline,24: PRINT SPACE$(10);
LOCATE statusline,24: PRINT ToolName$(ToolMode);
RETURN
PrintColorBar:
COLOR 0
LOCATE 19,1: PRINT " ";
colorbar = WINDOW(5)-10
LINE(0,colorbar)-(25,colorbar+20),currentcolor,bf
COLOR 1
x=30
FOR i=0 TO maxcolor
LINE (x,colorbar)-(x+8,y+colorbar+20),i,bf
LINE (x,colorbar)-(x+8,y+colorbar+20),1,b
x=x+8
NEXT i
LINE (30,colorbar+22)-(90+maxcolor*8,colorbar+26),0,bf
x=30+currentcolor*8:LINE ( x,colorbar+22)-(x+8,colorbar+26),1,bf
RETURN
CheckColor:
IF currentY<colorbar OR currentY>colorbar+20 THEN RETURN
IF currentX<30 THEN RETURN
i=INT((currentX-30)/8)
IF i>maxcolor THEN RETURN
currentcolor=i
LINE(236,cbtop+1)-(300,cbtop+29),0,bf
LINE(236+rgb%(i,1)*4,cbtop+4)-STEP(3,7),1,bf
LINE(236+rgb%(i,2)*4,cbtop+12)-STEP(3,7),1,bf
LINE(236+rgb%(i,3)*4,cbtop+20)-STEP(3,7),1,bf
LOCATE statusline+1,1:PRINT SPACE$(38);
GOSUB PrintColorBar
RETURN
EditColor:
IF currentY<cbtop+1 OR currentX<236 THEN RETURN
IF currentY>cbtop+29 OR currentX>300 THEN RETURN
i=(currentY-cbtop-1)\10 : j=(currentX-236)\4
IF i>2 OR j>15 THEN RETURN
cuc=currentcolor
LINE(236,cbtop+i*8+4)-(300,cbtop+11+i*8),0,bf
LINE (236+j*4,cbtop+i*8+4)-STEP(3,7),1,bf
rgb%(cuc,i+1)=j:PALETTE cuc,rgb%(cuc,1)/15,rgb%(cuc,2)/15,rgb%(cuc,3)/15
LOCATE statusline+1,1
PRINT "Col";cuc;"R";rgb%(cuc,1);INT(rgb%(cuc,1)*6.666)/100;"G";rgb%(cuc,2);INT(rgb%(cuc,2)*6.666)/100;"B";rgb%(cuc,3);INT(rgb%(cuc,3)*6.666)/100;" ";
RETURN
PrintEditBox:
LINE(234,cbtop)-(301,cbtop+30),1,b
COLOR 1
LOCATE 14,29:PRINT "R";
LOCATE 15,29:PRINT "G";
LOCATE 16,29:PRINT "B";
RETURN
CheckSave:
IF fEnlarge THEN GOSUB Shrink
CancelCommand=0
IF Change THEN
BEEP
GOSUB GetPicture
CLS
PRINT "Current file is not saved."
PRINT "Do you want to save it?"
PRINT " Press Y key if you want to save it"
PRINT " Press N key if don't you want to save it"
PRINT " Press C key if you want to cancel command"
Response=0
WHILE Response=0
a$=INKEY$
IF a$<>"" THEN
a$=UCASE$(a$)
IF a$="Y" THEN Response=1
IF a$="N" THEN Response=2
IF a$="C" THEN Response=3
IF Response=0 THEN BEEP
END IF
WEND
GOSUB RedrawPicture
IF Response=1 THEN GOSUB SaveFileAs
IF Response=3 THEN CancelCommand=-1
END IF
RETURN
SUB GetCurrentXY STATIC
SHARED currentX,currentY,InsideBob,Bobright,bobbottom
dummy=MOUSE(0)
currentX=MOUSE(1)
currentY=MOUSE(2)
InsideBob=-1
IF currentX>Bobright OR currentY>bobbottom THEN InsideBob=0
IF currentX<0 OR currentY<0 THEN InsideBob=0
END SUB
SUB PrintCurrentXY STATIC
SHARED statusline,currentX,currentY
LOCATE statusline,1: PRINT "Bob size X:";currentX;
LOCATE statusline,17: PRINT "Y:";currentY;
END SUB
SUB DrawBoundary STATIC
SHARED Bobright,bobbottom
x=Bobright+10
y=bobbottom+10
LINE (0,y)-(x,y)
LINE (x,y)-(x,0)
LINE (0,bobbottom+1)-(x,bobbottom+1)
LINE (Bobright+1,y)-(Bobright+1,0)
END SUB
SUB InvertVideo STATIC
CALL SetDrMd& (WINDOW(8),3)
END SUB
SUB NormalVideo STATIC
CALL SetDrMd& (WINDOW(8),1)
END SUB
SUB FrameRect(rect()) STATIC
LINE (rect(1),rect(0))-(rect(3),rect(0))
LINE (rect(3),rect(0))-(rect(3),rect(2))
LINE (rect(3),rect(2))-(rect(1),rect(2))
LINE (rect(1),rect(2))-(rect(1),rect(0))
END SUB
IgnoreBreak:
RETURN